﻿Imports System.Xml
Imports System.Data
Imports System.Net
Imports System.Web
Imports System

''' <summary>
''' This class is used to call the XMLSERVICE program on an AS/400 - IBM i system to query a database or call a command or 
''' program and return the data in a .Net usable format such as a DataSet or DataTable. 
''' This database class should work with V5R4 and above of the operating system. 
''' </summary>
''' <remarks></remarks>
Public Class XmlServicei

    Private _LastError As String
    Private _DS1 As DataSet
    Private _dtColumnDefinitions As DataTable
    Private _iColumnCount As Integer
    Private _iRowCount As Integer
    Private _dtReturnDataTable As DataTable
    Private _bXMLIsLoaded As Boolean = False
    Private _BaseURL As String = ""
    Private _DB2Parm As String = "db2=@@db2value&uid=@@uidvalue&pwd=@@pwdvalue&ipc=@@ipcvalue&ctl=@@ctlvalue&xmlin=@@xmlinvalue&xmlout=@@xmloutvalue"
    Private _DSCMD1 As DataSet
    Private _dtCommandResponse As DataTable
    Private _dtProgramResponse As DataTable
    Private _User As String = ""
    Private _Password As String = ""
    Private _IPCINfo As String = "/tmp/xmlservicei"
    Private _DB2Info As String = "*LOCAL"
    Private _LastHTTPResponse As String = ""
    Private _LastXMLResponse As String = ""
    Private _HttpTimeout As Integer = 60000

    ''' <summary>
    ''' Set HTTP timeout for XMLSERVICE requests
    ''' </summary>
    ''' <param name="iTimeout">HTTP timeout in milliseconds</param>
    ''' <returns>True - Success, False - Fail</returns>
    ''' <remarks></remarks>
    Function SetHttpTimeout(iTimeout As Integer) As Boolean
        Try
            _LastError = ""
            _HttpTimeout = iTimeout
            Return True
        Catch ex As Exception
            _LastError = ex.Message
            Return False
        End Try
    End Function

    ''' <summary>
    ''' Program call parameter structure
    ''' </summary>
    ''' <remarks></remarks>
    Structure PgmParmList
        Dim parmtype As String
        Dim parmvalue As String
    End Structure
    ''' <summary>
    ''' Program call return structure
    ''' </summary>
    ''' <remarks></remarks>
    Structure RtnPgmCall
        Dim success As Boolean
        Dim parms() As PgmParmList
    End Structure
    ''' <summary>
    ''' Stored procedure parameter list
    ''' </summary>
    ''' <remarks></remarks>
    Structure ProcedureParmList
        Dim parmtype As String
        Dim parmvalue As String
        Dim parmname As String
    End Structure
    ''' <summary>
    ''' Stored procedure return structure
    ''' </summary>
    ''' <remarks></remarks>
    Structure RtnProcedureCall
        Dim success As Boolean
        Dim parms() As PgmParmList
    End Structure
    ''' <summary>
    ''' Set base URL to XMLCGI program.
    ''' Example: http://1.1.1.1:30000/cgi-bin/xmlcgi.pgm
    ''' Set this value one time each time the class is instantiated.
    ''' </summary>
    ''' <param name="sURL"></param>
    ''' <returns></returns>
    ''' <remarks></remarks>
    Function SetBaseURL(sURL As String) As Boolean
        Try
            _LastError = ""
            _BaseURL = sURL
            Return True
        Catch ex As Exception
            _LastError = ex.Message
            Return False
        End Try
    End Function
    ''' <summary>
    ''' Set base user info for XMLCGI program calls.
    ''' Set this value one time each time the class is instantiated.
    ''' </summary>
    ''' <param name="sUser">IBM i User</param>
    ''' <param name="sPassword">IBM i Password</param>
    ''' <returns>True - Success, False - Fail</returns>
    ''' <remarks></remarks>
    Function SetUserInfo(sUser As String, sPassword As String) As Boolean
        Try
            _LastError = ""
            _User = sUser
            _Password = sPassword
            Return True
        Catch ex As Exception
            _LastError = ex.Message
            Return False
        End Try
    End Function

    ''' <summary>
    ''' Set IPC info. 
    ''' The class defaults to /tmp/rjsxmlservice so this call not needed unless you want to use custom IPC info
    ''' </summary>
    ''' <param name="sIPCInfo">IPC info. Example: /tmp/rjsxmlservice</param>
    ''' <returns>True - Success, False - Fail</returns>
    ''' <remarks></remarks>
    Function SetIpcInfo(Optional sIPCInfo As String = "/tmp/rjsxmlservice") As Boolean
        Try
            _LastError = ""
            'Set IPC info only if a valur is passed. 
            If sIPCInfo <> "" Then
                _IPCINfo = sIPCInfo
            End If
            Return True
        Catch ex As Exception
            _LastError = ex.Message
            Return False
        End Try
    End Function
    ''' <summary>
    ''' Set DB2 system info. Defaults to *LOCAL to access local system database
    ''' </summary>
    ''' <param name="sDB2Info"></param>
    ''' <returns></returns>
    ''' <remarks></remarks>
    Function SetDb2Info(Optional sDB2Info As String = "*LOCAL") As Boolean
        Try
            _LastError = ""
            _DB2Info = sDB2Info
            Return True
        Catch ex As Exception
            _LastError = ex.Message
            Return False
        End Try
    End Function
    ''' <summary>
    ''' This function gets the XML DataSet of data that was loaded with LoadDataSetFromXMLFile
    ''' </summary>
    ''' <returns>Data table of data or nothing if no data set</returns>
    ''' <remarks></remarks>
    Public Function GetDataSet() As DataSet
        Try
            _LastError = ""

            If _bXMLIsLoaded = False Then
                Throw New Exception("No XML data is currently loaded. Call LoadDataSetFromXMLFile to load an XML file first.")
            End If

            Return _DS1
        Catch ex As Exception
            _LastError = ex.Message
            Return Nothing
        End Try
    End Function
    ''' <summary>
    ''' Returns last error message string
    ''' </summary>
    ''' <returns>Last error message string</returns>
    ''' <remarks></remarks>
    Public Function GetLastError() As String
        Try
            Return _LastError
        Catch ex As Exception
            Return ""
        End Try
    End Function
    ''' <summary>
    ''' Returns last XML response message string
    ''' </summary>
    ''' <returns>Last XML response message string</returns>
    ''' <remarks></remarks>
    Public Function GetLastXmlResponse() As String
        Try
            Return _LastXMLResponse
        Catch ex As Exception
            Return ""
        End Try
    End Function
    ''' <summary>
    ''' This function gets the DataTable of data loaded from XML with LoadDataSetFromXMLFile
    ''' </summary>
    ''' <returns>Data table of data or nothing if no data set</returns>
    ''' <remarks></remarks>
    Public Function GetDataTable() As DataTable
        Try
            _LastError = ""

            If _bXMLIsLoaded = False Then
                Throw New Exception("No XML data is currently loaded. Call LoadDataSetFromXMLFile to load an XML file first.")
            End If

            Return _dtReturnDataTable
        Catch ex As Exception
            _LastError = ex.Message
            Return Nothing
        End Try
    End Function
    ''' <summary>
    ''' This kills the currently active IPC service instance on IBM i system.
    ''' These jobs are all marked as XTOOLKIT and can be seen by running 
    ''' the following CL command: WRKACTJOB JOB(XTOOLKIT)
    ''' Note: If you will be doing a lot of work, you can leave the job instantiated. Otherwise kill the XTOOLKIT job 
    ''' if you're done using it. 
    ''' </summary>
    ''' <returns>True - kill succeeded. Return XML will always be blank so we will always return true most likely.</returns>
    ''' <remarks></remarks>
    Public Function KillService() As Boolean

        Dim sdb2parm As String = _DB2Parm
        Dim sRtnXML As String = ""
        Dim rtnload As Boolean = False

        Try

            'Kill service call base XML string 
            Dim sXMLIN As String = "<?xml version='1.0'?>" & vbCrLf & _
          "<?xml-stylesheet type='text/xsl' href='/DemoXslt.xsl'?>" & vbCrLf & _
                    "<script>" & vbCrLf & _
                    "</script>"

            Dim sXMLOUT As String = "500000"

            _LastError = ""

            sdb2parm = sdb2parm.Replace("@@db2value", _DB2Info)
            sdb2parm = sdb2parm.Replace("@@uidvalue", _User)
            sdb2parm = sdb2parm.Replace("@@pwdvalue", _Password)
            sdb2parm = sdb2parm.Replace("@@ipcvalue", _IPCINfo)
            sdb2parm = sdb2parm.Replace("@@ctlvalue", "*immed")
            sdb2parm = sdb2parm.Replace("@@xmlinvalue", sXMLIN)
            sdb2parm = sdb2parm.Replace("@@xmloutvalue", sXMLOUT)
            sdb2parm = sdb2parm & "&submit=*immed end (kill job)"

            'Execute request
            sRtnXML = HttpRequest(_BaseURL, "POST", sdb2parm, _HttpTimeout)

            'Bail out if HTTPRequest failure
            If sRtnXML.StartsWith("ERROR") Then
                Throw New Exception(sRtnXML)
            End If

            'Execute XMLSERVICE POST request to run command
            sRtnXML = HttpRequest(_BaseURL, "POST", sdb2parm, _HttpTimeout)

            'Bail out if +++ success not returned in XML response
            If sRtnXML = "" Then
                _LastXMLResponse = sRtnXML
                Return True
            Else
                Throw New Exception(sRtnXML)
            End If

        Catch ex As Exception
            _LastXMLResponse = sRtnXML
            _LastError = ex.Message
            Return False
        End Try
    End Function
    ''' <summary>
    ''' This kills the temporary IPC directories in IFS directory /tmp or other specified location
    ''' It's a good idea to periodically clean up these directories either via this function or
    ''' via a job on IBM i that does a RMDIR.  Ex: RMDIR  '/tmp/xmlservicei*'
    ''' </summary>
    ''' <param name="sIfsDirPath">IFS directory path to remove. Wildcards are OK.  Ex: /tmp/xmlservicei*'</param>
    ''' <returns>True - IFS directory kill succeeded. False - IFS directory kill failed.</returns>
    ''' <remarks></remarks>
    Public Function KillIpcIfsDirectories(sIfsDirPath As String) As Boolean

        Dim rtn As Boolean = False

        Try

            _LastXMLResponse = ""
            _LastError = ""
            _LastHTTPResponse = ""

            'Erase directories if path passed
            If sIfsDirPath.Trim <> "" Then
                rtn = ExecuteCommand("RMDIR DIR('" & sIfsDirPath.Trim & "')")
            Else
                Throw New Exception("No IFS directory path specified.")
            End If

            Return rtn

        Catch ex As Exception
            '_LastXMLResponse = ' This value should already be set
            _LastError = ex.Message
            Return False
        End Try
    End Function

    ''' <summary>
    ''' This function runs an SQL INSERT, UPDATE, DELETE or other action query against the DB2 database with selected SQL statement.
    ''' </summary>
    ''' <param name="sSQL">SQL INSERT, UPDATE and DELETE. Select is not allowed </param>
    ''' <param name="sOutputFile">PC output file for XML response data</param>
    ''' <returns>True - Query service call succeeded, False - Query service call failed</returns>
    ''' <remarks>Note: Committment control is disabled via the commit='non' option so journaling is not used at the moment on any files you plan to modify via INSERT/UPDATE/DELETE</remarks>
    Public Function ExecuteSqlNonQuery(sSQL As String, Optional sOutputFile As String = "") As Boolean

        Dim sdb2parm As String = _DB2Parm
        Dim sRtnXML As String = ""
        Dim rtnexecute As Boolean
        Dim sSuccessValue As String = "<execute stmt='stmt1'>@@CHR10<success>+++ success stmt1</success>@@CHR10</execute>"

        Dim od As New OleDb.OleDbCommand

        Try

            sRtnXML = ""
            _LastHTTPResponse = ""
            _LastXMLResponse = ""

            'Replace success values with correct ascii values. The return data contains a line feed
            sSuccessValue = sSuccessValue.Replace("@@CHR10", Chr(10))

            'SQL query base XML string. This version disables committment control.
            Dim sXMLIN As String = "<?xml version='1.0'?>" & vbCrLf & _
                 "<?xml-stylesheet type='text/xsl' href='/DemoXslt.xsl'?>" & vbCrLf & _
                    "<script>" & vbCrLf & _
                    "<sql>" & vbCrLf & _
                    "<options options='noauto' commit='none' error='fast'/>" & vbCrLf & _
                    "</sql>" & vbCrLf & _
                    "<sql>" & vbCrLf & _
                    "<connect conn='myconn' options='noauto' error='fast'/>" & vbCrLf & _
                    "</sql>" & vbCrLf & _
                    "<sql>" & vbCrLf & _
                    "<prepare conn='myconn'>" & sSQL & "</prepare>" & vbCrLf & _
                    "</sql>" & vbCrLf & _
                    "<sql>" & vbCrLf & _
                    "<execute/>" & vbCrLf & _
                    "</sql>" & vbCrLf & _
                    "<sql>" & vbCrLf & _
                    "<describe desc='col'/>" & vbCrLf & _
                    "</sql>" & vbCrLf & _
                    "<sql>" & vbCrLf & _
                    "<fetch block='all' desc='on'/>" & vbCrLf & _
                    "</sql>" & vbCrLf & _
                    "<sql>" & vbCrLf & _
                    "<free/>" & vbCrLf & _
                    "</sql>" & vbCrLf & _
                    "</script>"

            Dim sXMLOUT As String = "500000" 'Buffer size

            _LastError = ""

            If sSQL.ToUpper.Trim.StartsWith("INSERT") = False And sSQL.ToUpper.Trim.StartsWith("UPDATE") = False And sSQL.ToUpper.Trim.StartsWith("DELETE") = False Then
                Throw New Exception("Only SQL INSERT, UPDATE and DELETE actions are allowed.")
            End If

            'Replace parms into XML string
            sdb2parm = sdb2parm.Replace("@@db2value", _DB2Info)
            sdb2parm = sdb2parm.Replace("@@uidvalue", _User)
            sdb2parm = sdb2parm.Replace("@@pwdvalue", _Password)
            sdb2parm = sdb2parm.Replace("@@ipcvalue", _IPCINfo)
            sdb2parm = sdb2parm.Replace("@@ctlvalue", "*sbmjob")
            sdb2parm = sdb2parm.Replace("@@xmlinvalue", sXMLIN)
            sdb2parm = sdb2parm.Replace("@@xmloutvalue", sXMLOUT)

            'Execute request 
            sRtnXML = HttpRequest(_BaseURL, "POST", sdb2parm, _HttpTimeout)

            'Bail out if HTTPRequest failure
            If sRtnXML.StartsWith("ERROR") Then
                Throw New Exception(sRtnXML)
            End If

            'Save last response
            _LastXMLResponse = sRtnXML

            'Check for successin XML response data
            If sRtnXML.IndexOf(sSuccessValue) > 0 Then
                rtnexecute = True
            Else
                rtnexecute = False
            End If

            Return rtnexecute

        Catch ex As Exception
            _LastXMLResponse = sRtnXML
            _LastError = ex.Message
            Return False
        End Try
    End Function

    ''' <summary>
    ''' This function queries the DB2 database with selected SQL statement and returns results to 
    ''' specified XML file.
    ''' </summary>
    ''' <param name="sSQL">SQL Select. INSERT, UPDATE and DELETE not allowed </param>
    ''' <param name="sOutputFile">Optional PC output file for XML response data. Otherwise data set is created from memory.</param>
    ''' <returns>True - Query service call succeeded, False - Query service call failed</returns>
    ''' <remarks></remarks>
    Public Function ExecuteSqlQueryPrepared(sSQL As String, Optional sOutputFile As String = "") As Boolean

        Dim sdb2parm As String = _DB2Parm
        Dim sRtnXML As String = ""
        Dim rtnload As Boolean

        Try

            sRtnXML = ""
            _LastHTTPResponse = ""
            _LastXMLResponse = ""

            'SQL query base XML string
            Dim sXMLIN As String = "<?xml version='1.0'?>" & vbCrLf & _
                 "<?xml-stylesheet type='text/xsl' href='/DemoXslt.xsl'?>" & vbCrLf & _
                    "<script>" & vbCrLf & _
                    "<sql>" & vbCrLf & _
                    "<options options='noauto' autocommit='off'/>" & vbCrLf & _
                    "</sql>" & vbCrLf & _
                    "<sql>" & vbCrLf & _
                    "<connect conn='myconn' options='noauto'/>" & vbCrLf & _
                    "</sql>" & vbCrLf & _
                    "<sql>" & vbCrLf & _
                    "<prepare conn='myconn'>" & sSQL.Trim & "</prepare>" & vbCrLf & _
                    "</sql>" & vbCrLf & _
                    "<sql>" & vbCrLf & _
                    "<execute/>" & vbCrLf & _
                    "</sql>" & vbCrLf & _
                    "<sql>" & vbCrLf & _
                    "<describe desc='col'/>" & vbCrLf & _
                    "</sql>" & vbCrLf & _
                    "<sql>" & vbCrLf & _
                    "<fetch block='all' desc='on'/>" & vbCrLf & _
                    "</sql>" & vbCrLf & _
                    "<sql>" & vbCrLf & _
                    "<free/>" & vbCrLf & _
                    "</sql>" & vbCrLf & _
                    "</script>"

            Dim sXMLOUT As String = "500000" 'Buffer size

            _LastError = ""

            If sSQL.ToUpper.Contains("UPDATE ") Or sSQL.ToUpper.Contains("DELETE ") Or sSQL.ToUpper.Contains("INSERT ") Then
                Throw New Exception("Only SQL selection queries are supported.")
            End If

            If sSQL.ToUpper.StartsWith("UPDATE") Or sSQL.ToUpper.StartsWith("DELETE") Or sSQL.ToUpper.StartsWith("INSERT") Then
                Throw New Exception("SQL statement cannot start with INSERT, UPDATE or DELETE.")
            End If

            If sSQL.ToUpper.StartsWith("SELECT") = False Then
                Throw New Exception("SQL selection must start with SELECT")
            End If

            'Replace parms into XML string
            sdb2parm = sdb2parm.Replace("@@db2value", _DB2Info)
            sdb2parm = sdb2parm.Replace("@@uidvalue", _User)
            sdb2parm = sdb2parm.Replace("@@pwdvalue", _Password)
            sdb2parm = sdb2parm.Replace("@@ipcvalue", _IPCINfo)
            sdb2parm = sdb2parm.Replace("@@ctlvalue", "*sbmjob")
            sdb2parm = sdb2parm.Replace("@@xmlinvalue", sXMLIN)
            sdb2parm = sdb2parm.Replace("@@xmloutvalue", sXMLOUT)

            'Execute request 
            sRtnXML = HttpRequest(_BaseURL, "POST", sdb2parm, _HttpTimeout)

            'Bail out if HTTPRequest failure
            If sRtnXML.StartsWith("ERROR") Then
                Throw New Exception(sRtnXML)
            End If

            'Save to file and reload XML
            If sOutputFile.Trim <> "" Then

                'Write results to output file if specified
                WriteStringToFile(sRtnXML, sOutputFile)

                'Load dataset from XML file
                rtnload = LoadDataSetFromXmlFile(sOutputFile)

            Else 'Load XML from memory

                'Load dataset from XML
                rtnload = LoadDataSetFromXmlString(sRtnXML)

            End If

            'Save last response
            _LastXMLResponse = sRtnXML

            If rtnload = True Then
                Return True
            Else
                Return False
            End If

        Catch ex As Exception
            _LastXMLResponse = sRtnXML
            _LastError = ex.Message
            Return False
        End Try
    End Function

    ''' <summary>
    ''' This function runs the specified IBM i CL command. The CL command can be a regular call or a SBMJOB type of command to submit a job.
    ''' </summary>
    ''' <param name="sCommandString">CL command line to execute</param>
    ''' <returns>True - Command call succeeded, False - Command call failed</returns>
    ''' <remarks></remarks>
    Public Function ExecuteCommand(sCommandString As String) As Boolean

        Dim sdb2parm As String = _DB2Parm
        Dim sRtnXML As String = ""

        Try

            sRtnXML = ""
            _LastHTTPResponse = ""
            _LastXMLResponse = ""
            _LastError = ""


            'Command call base XML string 
            Dim sXMLIN As String = "<?xml version='1.0'?>" & vbCrLf & _
          "<?xml-stylesheet type='text/xsl' href='/DemoXslt.xsl'?>" & vbCrLf & _
                    "<script>" & vbCrLf & _
                    "<cmd>" & sCommandString & "</cmd>" & vbCrLf & _
                    "</script>"

            Dim sXMLOUT As String = "32768" 'Buffer size

            'Replace parms into XML string
            sdb2parm = sdb2parm.Replace("@@db2value", _DB2Info)
            sdb2parm = sdb2parm.Replace("@@uidvalue", _User)
            sdb2parm = sdb2parm.Replace("@@pwdvalue", _Password)
            sdb2parm = sdb2parm.Replace("@@ipcvalue", _IPCINfo)
            sdb2parm = sdb2parm.Replace("@@ctlvalue", "*sbmjob")
            sdb2parm = sdb2parm.Replace("@@xmlinvalue", sXMLIN)
            sdb2parm = sdb2parm.Replace("@@xmloutvalue", sXMLOUT)

            'Execute request
            sRtnXML = HttpRequest(_BaseURL, "POST", sdb2parm, _HttpTimeout)

            'Bail out if +++ success not returned in XML response
            If sRtnXML.Contains("+++ success") Then
                _LastXMLResponse = sRtnXML
                Return True
            Else
                Throw New Exception(sRtnXML)
            End If

        Catch ex As Exception
            _LastXMLResponse = sRtnXML
            _LastError = ex.Message
            Return False
        End Try
    End Function
    ''' <summary>
    ''' This function runs the specified IBM i program call. 
    ''' You will need to pass in an array list of parameters.
    ''' </summary>
    ''' <param name="sProgram">IBM i program name</param>
    ''' <param name="sLibrary">IBM i program library</param>
    ''' <param name="aParmList">IBM i program parm list array</param>
    ''' <returns>True - Command call succeeded, False - Command call failed</returns>
    ''' <remarks></remarks>

    Public Function ExecuteProgram(sProgram As String, sLibrary As String, aParmList As ArrayList) As Boolean

        Dim sdb2parm As String = _DB2Parm
        Dim sRtnXML As String = ""

        Try

            sRtnXML = ""
            _LastHTTPResponse = ""
            _LastXMLResponse = ""
            _LastError = ""

            'Program call base XML string 
            Dim sXMLIN As String = "<?xml version='1.0'?>" & vbCrLf & _
            "<pgm name='@@pgmname' lib='@@pgmlibrary'>" & vbCrLf
            For Each pm As PgmParmList In aParmList
                sXMLIN = sXMLIN & "<parm><data type='" & pm.parmtype & "'>" & pm.parmvalue & "</data></parm>" & vbCrLf
            Next
            sXMLIN = sXMLIN & "</pgm>" & vbCrLf

            Dim sXMLOUT As String = "32768" 'Buffer size

            'Replace core program info in program string
            sXMLIN = sXMLIN.Replace("@@pgmname", sProgram)
            sXMLIN = sXMLIN.Replace("@@pgmlibrary", sLibrary)

            'Replace parms into XML string
            sdb2parm = sdb2parm.Replace("@@db2value", _DB2Info)
            sdb2parm = sdb2parm.Replace("@@uidvalue", _User)
            sdb2parm = sdb2parm.Replace("@@pwdvalue", _Password)
            sdb2parm = sdb2parm.Replace("@@ipcvalue", _IPCINfo)
            sdb2parm = sdb2parm.Replace("@@ctlvalue", "*sbmjob")
            sdb2parm = sdb2parm.Replace("@@xmlinvalue", sXMLIN)
            sdb2parm = sdb2parm.Replace("@@xmloutvalue", sXMLOUT)

            'Execute request
            sRtnXML = HttpRequest(_BaseURL, "POST", sdb2parm, _HttpTimeout)

            'Bail out if +++ success not returned in XML response
            If sRtnXML.Contains("+++ success") Then
                _LastXMLResponse = sRtnXML
                Return True
            Else
                Throw New Exception(sRtnXML)
            End If

            _LastXMLResponse = sRtnXML
            Return True

        Catch ex As Exception
            _LastXMLResponse = sRtnXML
            _LastError = ex.Message
            Return False
        End Try
    End Function
    ''' <summary>
    ''' This function runs the specified IBM i service program subprocedure call. 
    ''' http://www.statususer.org/pdf/20130212Presentation.pdf
    ''' http://174.79.32.155/wiki/pmwiki.php/XMLSERVICE/XMLSERVICESamples
    '''  <pgm name='ZZSRV' lib='XMLSERVICE' func='ZZTIMEUSA'>
    ''' <parm io='both'>
    ''' <data type='8A'>09:45 AM</data>
    ''' </parm>
    ''' <return>
    ''' <data type='8A'>nada</data>
    ''' </return>
    ''' </pgm>
    ''' </summary>
    ''' <param name="sProgram">IBM i program name</param>
    ''' <param name="sLibrary">IBM i program library</param>
    ''' <param name="sProcedure">IBM i procedure</param>
    ''' <param name="aParmList">IBM i program parm list array</param>
    ''' <returns>True - Command call succeeded, False - Command call failed</returns>
    ''' <remarks></remarks>

    Public Function ExecuteProgramProcedure(sProgram As String, sLibrary As String, sProcedure As String, aParmList As ArrayList, rtnParmList As ArrayList) As Boolean

        Dim sdb2parm As String = _DB2Parm
        Dim sRtnXML As String = ""

        Try

            sRtnXML = ""
            _LastHTTPResponse = ""
            _LastXMLResponse = ""
            _LastError = ""

            'Program call base XML string 
            Dim sXMLIN As String = "<?xml version='1.0'?>" & vbCrLf & _
            "<script>" & _
            "<pgm name='@@pgmname' lib='@@pgmlibrary' function='@@pgmfunction'>" & vbCrLf

            For Each pm As ProcedureParmList In aParmList
                sXMLIN = sXMLIN & "<parm io='input'><data type='" & pm.parmtype.Trim & "'>" & pm.parmvalue & "</data></parm>" & vbCrLf
            Next
            'If return parm list passed, set it up
            If rtnParmList.Count > 0 Then
                sXMLIN = sXMLIN & "<return>" & vbCrLf
                For Each pm As ProcedureParmList In rtnParmList
                    sXMLIN = sXMLIN & "<data type='" & pm.parmtype.Trim & "'>" & pm.parmvalue & "</data>" & vbCrLf
                Next
                sXMLIN = sXMLIN & "</return>"
            End If
            sXMLIN = sXMLIN & "</pgm>" & vbCrLf
            sXMLIN = sXMLIN & "</script>" & vbCrLf

            Dim sXMLOUT As String = "32768" 'Buffer size

            'Replace core program info in program string
            sXMLIN = sXMLIN.Replace("@@pgmname", sProgram)
            sXMLIN = sXMLIN.Replace("@@pgmlibrary", sLibrary)
            sXMLIN = sXMLIN.Replace("@@pgmfunction", sProcedure)

            ' ''TEST subprocedure call
            sXMLIN = "<?xml version='1.0'?>" & vbCrLf & _
            "<script>"
            'sXMLIN = ""
            ''sXMLIN = "<cmd comment='addlible'>ADDLIBLE LIB(RJSDOTNET) POSITION(*FIRST)</cmd>" & vbCrLf
            sXMLIN = sXMLIN & "<pgm name='XMLSVC001' lib='RJSDOTNET' func='SAMPLE1'>" & vbCrLf
            sXMLIN = sXMLIN & "<parm io='input'>" & vbCrLf
            'sXMLIN = sXMLIN & "<data type='65535A' varying='on'>Test</data>" & vbCrLf
            sXMLIN = sXMLIN & "<data type='200A'>Test</data>" & vbCrLf
            sXMLIN = sXMLIN & "</parm>" & vbCrLf
            sXMLIN = sXMLIN & "<return>" & vbCrLf
            sXMLIN = sXMLIN & "<data type='200A'></data>" & vbCrLf
            sXMLIN = sXMLIN & "</return>" & vbCrLf
            sXMLIN = sXMLIN & "</pgm>" & vbCrLf
            sXMLIN = sXMLIN & "</script>" & vbCrLf

            'Replace parms into XML string
            sdb2parm = sdb2parm.Replace("@@db2value", _DB2Info)
            sdb2parm = sdb2parm.Replace("@@uidvalue", _User)
            sdb2parm = sdb2parm.Replace("@@pwdvalue", _Password)
            sdb2parm = sdb2parm.Replace("@@ipcvalue", _IPCINfo)
            sdb2parm = sdb2parm.Replace("@@ctlvalue", "*sbmjob")
            sdb2parm = sdb2parm.Replace("@@xmlinvalue", sXMLIN)
            sdb2parm = sdb2parm.Replace("@@xmloutvalue", sXMLOUT)

            'Execute request
            sRtnXML = HttpRequest(_BaseURL, "POST", sdb2parm, _HttpTimeout)

            'Bail out if +++ success not returned in XML response
            If sRtnXML.Contains("+++ success") Then
                _LastXMLResponse = sRtnXML
                Return True
            Else
                Throw New Exception(sRtnXML)
            End If

            _LastXMLResponse = sRtnXML
            Return True

        Catch ex As Exception
            _LastXMLResponse = sRtnXML
            _LastError = ex.Message
            Return False
        End Try
    End Function

    ''' <summary>
    ''' This function loads an XML file that contains a data stream returned from the XMLSERVICE service program
    ''' </summary>
    ''' <param name="sXMLFile">XML File</param>
    ''' <returns>True-successfully loaded XML file, False-failed to load XML file</returns>
    ''' <remarks></remarks>
    Public Function LoadDataSetFromXmlFile(sXMLFile As String) As Boolean

        Try

            _LastError = ""

            'Bail if no XML file
            If System.IO.File.Exists(sXMLFile) = False Then
                Throw New Exception("XML file " & sXMLFile & " does not exist. Process cancelled.")
            End If

            ' Load XML data into a dataset  
            _DS1 = New DataSet()
            _DS1.ReadXml(sXMLFile)

            'Extract returned SQL column definitions from XML file
            _dtColumnDefinitions = _DS1.Tables("col")
            _iColumnCount = _DS1.Tables("col").Rows.Count
            _iRowCount = _DS1.Tables("data").Rows.Count / _iColumnCount

            'Start new DataTable for XML resultset returned by XMLSERVICE from IBM i
            _dtReturnDataTable = New DataTable
            For Each dr1 As DataRow In _DS1.Tables("col").Rows
                _dtReturnDataTable.Columns.Add(dr1(0), Type.GetType("System.String"))
            Next

            Dim colct As Integer
            Dim row2 As DataRow = Nothing
            For Each dr1 As DataRow In _DS1.Tables("data").Rows

                'If first column field, create new row
                If colct = 0 Then
                    row2 = _dtReturnDataTable.NewRow
                ElseIf colct = _iColumnCount Then
                    'All 
                    _dtReturnDataTable.Rows.Add(row2)
                    row2 = _dtReturnDataTable.NewRow
                    colct = 0
                End If

                'Set column value for row
                row2(dr1(0)) = dr1(1)
                colct = colct + 1
            Next

            'Add last row to dataset
            _dtReturnDataTable.Rows.Add(row2)

            _LastError = _iRowCount & " rows were returned from XML file " & sXMLFile

            _bXMLIsLoaded = True
            Return True

        Catch ex As Exception
            _LastError = ex.Message
            _bXMLIsLoaded = False
            Return False
        End Try
    End Function
    ''' <summary>
    ''' This function loads an XML string that contains a data stream returned from the XMLSERVICE service program
    ''' </summary>
    ''' <param name="sXMLString">XML File</param>
    ''' <returns>True-successfully loaded XML file, False-failed to load XML file</returns>
    ''' <remarks></remarks>
    Public Function LoadDataSetFromXmlString(sXMLString As String) As Boolean

        Try

            _LastError = ""

            Dim rdr As New System.IO.StringReader(sXMLString)

            ' Load XML data into a dataset  
            _DS1 = New DataSet()
            _DS1.ReadXml(rdr)

            'Extract returned SQL column definitions from XML file
            _dtColumnDefinitions = _DS1.Tables("col")
            _iColumnCount = _DS1.Tables("col").Rows.Count
            _iRowCount = _DS1.Tables("data").Rows.Count / _iColumnCount

            'Start new DataTable for XML resultset returned by XMLSERVICE from IBM i
            _dtReturnDataTable = New DataTable
            For Each dr1 As DataRow In _DS1.Tables("col").Rows
                _dtReturnDataTable.Columns.Add(dr1(0), Type.GetType("System.String"))
            Next

            Dim colct As Integer
            Dim row2 As DataRow = Nothing
            For Each dr1 As DataRow In _DS1.Tables("data").Rows

                'If first column field, create new row
                If colct = 0 Then
                    row2 = _dtReturnDataTable.NewRow
                ElseIf colct = _iColumnCount Then
                    'All 
                    _dtReturnDataTable.Rows.Add(row2)
                    row2 = _dtReturnDataTable.NewRow
                    colct = 0
                End If

                'Set column value for row
                row2(dr1(0)) = dr1(1)
                colct = colct + 1
            Next

            'Add last row to dataset
            _dtReturnDataTable.Rows.Add(row2)

            _LastError = _iRowCount & " rows were returned from XML string."

            _bXMLIsLoaded = True
            Return True

        Catch ex As Exception
            _LastError = ex.Message
            _bXMLIsLoaded = False
            Return False
        End Try
    End Function
    ''' <summary>
    ''' This function loads an XML string that contains a data stream returned from the XMLSERVICE service program
    ''' </summary>
    ''' <param name="sXMLString">XML File</param>
    ''' <returns>True-successfully loaded XML file, False-failed to load XML file</returns>
    ''' <remarks></remarks>
    Public Function LoadPgmCallDataSetFromXmlString(sXMLString As String) As Boolean

        Try

            _LastError = ""

            Dim rdr As New System.IO.StringReader(sXMLString)

            ' Load XML data into a dataset  
            _DS1 = New DataSet()
            _DS1.ReadXml(rdr)

            'Extract returned SQL column definitions from XML file
            ''dtColumnDefinitions = mDS1.Tables("col")
            _iRowCount = _DS1.Tables("data").Rows.Count

            'Start new DataTable for XML resultset returned by XMLSERVICE from IBM i
            _dtProgramResponse = New DataTable
            _dtProgramResponse.Columns.Add("parmtype", Type.GetType("System.String"))
            _dtProgramResponse.Columns.Add("parmvalue", Type.GetType("System.String"))

            Dim row2 As DataRow = Nothing
            For Each dr1 As DataRow In _DS1.Tables("data").Rows
                row2 = _dtProgramResponse.NewRow
                row2(0) = dr1(0)
                row2(1) = dr1(1)
                _dtProgramResponse.Rows.Add(row2)
            Next

            _LastError = _iRowCount & " rows were returned from XML string."

            _bXMLIsLoaded = True
            Return True

        Catch ex As Exception
            _LastError = ex.Message
            _bXMLIsLoaded = False
            Return False
        End Try
    End Function
    ''' <summary>
    ''' This function loads an XML string that contains a data stream returned from the XMLSERVICE service program
    ''' CL command call. The response is contained in the XML <cmd></cmd> tags.
    ''' </summary>
    ''' <param name="sXMLString">XML File</param>
    ''' <returns>True-successfully loaded XML file, False-failed to load XML file</returns>
    ''' <remarks></remarks>
    Public Function LoadCmdDataSetFromXmlString(sXMLString As String) As Boolean
        Try

            _LastError = ""

            Dim bErrors As Boolean
            Dim bSuccess As Boolean
            Dim sWorkMessage As String = ""

            'Dim rdr As New System.IO.StringReader(sXMLString)

            'Determine if success or failure
            If sXMLString.Contains("<error>") And sXMLString.Contains("</error>") Then
                bErrors = True
            ElseIf sXMLString.Contains("<success>") And sXMLString.Contains("</success>") Then
                bSuccess = True
            End If

            'Extract command response messages
            Dim iStartpos As Integer = 0
            Dim iEndPos As Integer = 0
            Dim iLength As Integer

            iStartpos = sXMLString.IndexOf("<cmd>")
            iEndPos = sXMLString.IndexOf("</cmd>") + 6
            iLength = iEndPos - iStartpos
            sWorkMessage = sXMLString.Substring(iStartpos, iLength)
            _LastError = sWorkMessage

            If bErrors = True Then
                Return False
            ElseIf bSuccess = True Then
                Return True
            Else
                Return False
            End If

            ''If neither succes or failure, bail out
            'If bErrors <> True And bSuccess <> True Then
            '    Throw New Exception("Response does not contain success or error tags.")
            'End If

            '' Load XML data into a dataset  
            'mDSCMD1 = New DataSet()
            'mDSCMD1.ReadXml(rdr)

            ''Extract returned SQL column definitions from XML file
            'dtCommandResponse = mDSCMD1.Tables("cmd")
            'iColumnCount = mDSCMD1.Tables("cmd").Rows.Count
            'iRowCount = mDSCMD1.Tables("cmd").Rows.Count

            ''If Not IsNothing(mDSCMD1.Tables("error")) Then
            ''    iErrors = mDSCMD1.Tables("error").Rows.Count
            ''End If
            ''If Not IsNothing(mDSCMD1.Tables("success")) Then
            ''    iSuccess = mDSCMD1.Tables("success").Rows.Count
            ''End If

            'Dim rowct As Integer
            'Dim row2 As DataRow = Nothing
            ''If errors, extract error info from response
            'If bErrors = True Then
            '    For rowct = 0 To mDSCMD1.Tables("error").Rows.Count - 1
            '        row2 = mDSCMD1.Tables("error").Rows(rowct)
            '        sWorkMessage = sWorkMessage & row2(0) & " "
            '    Next
            '    For rowct = 0 To mDSCMD1.Tables("joblog").Rows.Count - 1
            '        row2 = mDSCMD1.Tables("joblog").Rows(rowct)
            '        sWorkMessage = sWorkMessage & row2(0) & " "
            '    Next
            '    'Return false on errors
            '    mLastError = sWorkMessage
            '    Return False
            'End If
            ''If success, extract info from response
            'If bSuccess = True Then
            '    For rowct = 0 To mDSCMD1.Tables("cmd").Rows.Count - 1
            '        row2 = mDSCMD1.Tables("cmd").Rows(rowct)
            '        sWorkMessage = sWorkMessage & row2(0) & " "
            '    Next
            '    'Return false on errors
            '    mLastError = sWorkMessage
            '    Return True
            'End If

            'If we got this far, there's an issue
            'mLastError = sWorkMessage
            'Return False

        Catch ex As Exception
            _LastError = ex.Message
            Return False
        End Try
    End Function

    Function GetUrlToString(sURL As String) As String
        Try

            Dim fr As System.Net.HttpWebRequest
            Dim targetURI As New Uri(sURL)
            Dim s1 As String = ""
            fr = DirectCast(HttpWebRequest.Create(targetURI), System.Net.HttpWebRequest)
            fr.Method = "GET"
            If (fr.GetResponse().ContentLength > 0) Then
                Dim str As New System.IO.StreamReader(fr.GetResponse().GetResponseStream())
                s1 = str.ReadToEnd
                str.Close()
            End If

            Return s1

        Catch ex As System.Net.WebException
            _LastError = ex.Message
            Return ""
        End Try

    End Function
    ''' <summary>
    ''' Make an HTTP request with selected URL and get response
    ''' </summary>
    ''' <param name="URL">URL</param>
    ''' <param name="method">POST or GET</param>
    ''' <param name="POSTdata">Data to post ont he request</param>
    ''' <param name="iTimeout">Optional HTTP request timeout. Default = 60000 milliseconds</param>
    ''' <returns>XML response or error string starting with "ERROR" </returns>
    ''' <remarks></remarks>
    Function HttpRequest(URL As String, method As String, POSTdata As String, Optional iTimeout As Integer = 60000) As String
        Dim responseData As String = ""
        Try
            _LastHTTPResponse = ""
            Dim hwrequest As Net.HttpWebRequest = Net.WebRequest.Create(URL)
            hwrequest.Accept = "*/*"
            hwrequest.AllowAutoRedirect = True
            hwrequest.UserAgent = "http_requester/0.1"
            hwrequest.Timeout = iTimeout
            hwrequest.Method = method
            If hwrequest.Method = "POST" Then
                hwrequest.ContentType = "application/x-www-form-urlencoded"
                Dim encoding As New Text.ASCIIEncoding() 'Use UTF8Encoding for XML requests
                Dim postByteArray() As Byte = encoding.GetBytes(POSTdata)
                hwrequest.ContentLength = postByteArray.Length
                Dim postStream As IO.Stream = hwrequest.GetRequestStream()
                postStream.Write(postByteArray, 0, postByteArray.Length)
                postStream.Close()
            End If
            Dim hwresponse As Net.HttpWebResponse = hwrequest.GetResponse()
            _LastHTTPResponse = hwresponse.StatusCode & " " & hwresponse.StatusDescription
            If hwresponse.StatusCode = Net.HttpStatusCode.OK Then
                Dim responseStream As IO.StreamReader = _
                  New IO.StreamReader(hwresponse.GetResponseStream())
                responseData = responseStream.ReadToEnd()
            End If
            hwresponse.Close()
        Catch e As Exception
            responseData = "ERROR - An HTTP error occurred: " & e.Message
        End Try
        Return responseData
    End Function
    ''' <summary>
    ''' Write text string to file
    ''' </summary>
    ''' <param name="sTextString">Text string value</param>
    ''' <param name="sOutputFile">Output file</param>
    ''' <param name="bAppend">True=Append</param>
    ''' <param name="bReplace">True=Replace file before writing</param>
    ''' <returns>True-Success, False-Failure to write</returns>
    ''' <remarks></remarks>
    Function WriteStringToFile(ByVal sTextString As String, ByVal sOutputFile As String, Optional bAppend As Boolean = False, Optional bReplace As Boolean = True) As Boolean
        'Write text string to output file
        Try
            _LastError = ""

            If System.IO.File.Exists(sOutputFile) = True Then
                If bReplace = True Then
                    System.IO.File.Delete(sOutputFile)
                End If
            End If

            Using objWriter As New System.IO.StreamWriter(sOutputFile, bAppend)

                objWriter.Write(sTextString)

                objWriter.Close()

            End Using

            Return True

        Catch ex As Exception
            _LastError = ex.Message
            Return False
        End Try
    End Function
    ''' <summary>
    ''' Read text file into memory
    ''' </summary>
    ''' <param name="sInputFile"></param>
    ''' <returns></returns>
    ''' <remarks></remarks>
    Function ReadTextFile(ByVal sInputFile As String) As String
        Try

            If IO.File.Exists(sInputFile) = False Then
                Throw New Exception(sInputFile & " does not exist.")
            End If

            Using objReader As New System.IO.StreamReader(sInputFile, True)
                Dim sWork As String = ""

                'Read all text
                sWork = objReader.ReadToEnd()

                objReader.Close()

                Return sWork

            End Using
        Catch ex As Exception
            _LastError = ex.Message
            Return ""
        End Try
    End Function
    ''' <summary>
    ''' Encode URL
    ''' </summary>
    ''' <param name="sURL">URL to encode</param>
    ''' <returns></returns>
    ''' <remarks></remarks>
    Function UrlEncode(sURL) As String
        Try
            Dim oHTTP As New System.Web.HttpUtility
            sURL = oHTTP.UrlEncode(sURL)
            Return sURL
        Catch ex As Exception
            _LastError = ex.Message
            'Return original URL
            Return sURL
        End Try
    End Function

End Class
